home *** CD-ROM | disk | FTP | other *** search
/ Enter 2004 January / enter-2004-01.iso / files / maxima-5.9.0.exe / {app} / share / maxima / 5.9.0 / src / factor.lisp < prev    next >
Encoding:
Text File  |  2003-02-09  |  43.1 KB  |  1,419 lines
  1. ;;; -*-  Mode: Lisp; Package: Maxima; Syntax: Common-Lisp; Base: 10 -*- ;;;;
  2. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  3. ;;;     The data in this file contains enhancments.                    ;;;;;
  4. ;;;                                                                    ;;;;;
  5. ;;;  Copyright (c) 1984,1987 by William Schelter,University of Texas   ;;;;;
  6. ;;;     All rights reserved                                            ;;;;;
  7. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  8. ;;;     (c) Copyright 1981 Massachusetts Institute of Technology         ;;;
  9. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  10.  
  11. (in-package "MAXIMA")
  12. (macsyma-module factor)
  13.  
  14. ;;; This is the FACTOR package. 
  15.  
  16. ;;;      THIS IS THE NEW FACTORING PACKAGE. THE FUNCTION
  17. ;;;     FACTOR72 TAKES A PRIMITIVE SQUARE-FREE POLY AS INPUT THE OUTPUT IS A
  18. ;;;     LIST OF FACTORS THE FUNCTION FACTOR1972 IS ABOVE FACTOR72 AND IT
  19. ;;;     TAKES CARE OF REPEATED FACTORS OVER THE GAUSSIAN INTEGERS BEFORE
  20. ;;;     CALLING FACTOR72 THE FUNCTION Z1 TAKES TWO FACTORS IN ONE VARIABLE
  21. ;;;     AND ONE POLY IN SEVERAL VARIABLES AS INPUT Z1 TAKES THESE FACTORS IN
  22. ;;;     ONE VARIABLES AND BUILDS OUT OF THEM TWO FACTORS OF THE GIVEN POLY IN
  23. ;;;     SEVERAL VARIABLES
  24.  
  25. (LOAD-MACSYMA-MACROS RATMAC)
  26.  
  27. (DECLARE-TOP(*LEXPR $FACTOR)
  28.      (SPECIAL *STOP* TRL* *XN SHARPCONT SUBVAR1 ANOTYPE INVC FCTC
  29.           SUBVAL1 VAR MCFLAG ALCINV *AB* MONIC* INTBS*
  30.           *PRIME *G* MODULU* NEGFLAG PLIM LISTELM MANY* *INL3
  31.           *SHARPA *SHARPB LIMK SPLIT* ALC IND P L DOSIMP *ODR*
  32.           *I* MCFLAG ELM NE RES FACT1 FACT2 SUBVAR
  33.          SUBVAL OVARLIST VALIST DLP NN* DF1 DF2 DN* FCS* UU*)
  34.      (GENPREFIX FCT)
  35.      (FIXNUM #-cl (LOG2))) 
  36.  
  37. (declare-top(special afixn fctcfixn invcfixn))
  38. (defmacro afixn (row col) `(arraycall fixnum afixn ,row ,col))
  39. (defmacro fctcfixn (ind) `(arraycall fixnum fctcfixn ,ind))
  40. (defmacro invcfixn (ind) `(arraycall fixnum invcfixn ,ind))
  41.  
  42. ;; Internal specials
  43.  
  44. (DEFMVAR GAUSS NIL)
  45. (DEFMVAR *MIN* NIL)
  46. (DEFMVAR *MX* NIL)
  47. (DEFMVAR MINPOLY* NIL)
  48. (DEFMVAR MPLC* NIL)
  49. (DEFMVAR MM* 1)
  50. (DEFMVAR ALPHA NIL)
  51. (DEFMVAR SMALLPRIMES '(3 5 7 11. 13. 17. 19. 23. 29. 31. 37.
  52.              41. 43. 47. 53. 59. 61.))
  53.  
  54. ;; External specials
  55.  
  56. (DEFMVAR $NALGFAC T "If t use bmt's algebraic factoring algorithm")
  57. (DEFMVAR $NEWFAC NIL)
  58.  
  59. (DEFUN CSQFRP ($FACTORFLAG)
  60.   (NULL (zl-DELETE 1 (ODDELM (CDR (CFACTOR $FACTORFLAG))))))
  61.  
  62. (DEFUN PRIMCYCLO (N &AUX *G* (NL (CFACTORW N)))
  63.   (SETQ NL (SLOOP FOR (C E) ON NL BY 'CDDR
  64.          NCONC (*MAKE-LIST E C)))
  65.   (let ((res (CYCLOTOMIC (LIST N NL))))
  66.     (cond ((consp res) (p-terms res))
  67.       ((eql 0 res) nil)
  68.       (t (list 0 res)))))
  69.  
  70. (DEFUN FACTXN+-1 (P) 
  71.        (LET ((*G* (CAR P))
  72.          ($FACTORFLAG T)) 
  73.         (COND ((EQUAL 1 (CADR P)) (LIST P))
  74.           ((EQUAL (CDDR P) '(1 0 1))
  75.            (FACTXN+1 (CADR P))) 
  76.           ((EQUAL (CDDR P) '(1 0 -1))
  77.            (FACTXN-1 (CADR P)))))) 
  78.  
  79. (DEFMFUN CFACTORW (N) (LET (($FACTORFLAG T)) (CFACTOR N)))
  80.  
  81. (DEFUN FACTXN-1 (N)
  82.        (COND ((EVENP N)
  83.           (APPEND (FACTXN-1 (// N 2)) (FACTXN+1 (// N 2))))
  84.          (T (MAPCAR #'CYCLOTOMIC (DIVISORS (CFACTOR N)))))) 
  85.  
  86. (defun factxn+1 (n)
  87.   (cond (gauss
  88.      (let* ((gauss nil) (facl (factxn+1 n)))
  89.        (cond ((oddp n) facl)
  90.          (t (let (($gcd '$subres)
  91.               (pfac (list *g* (// n 2) 1 0 alpha)))
  92.               (mapcan #'(lambda (q) (firstn 2 (pgcdcofacts q pfac)))
  93.                   facl))))))
  94.     (t (let ((m 1) (nl (reverse (cfactor n))))
  95.          (when (equal 2 (cadr nl))
  96.            (setq m (expt 2 (car nl)))
  97.            (setq nl (cddr nl)))
  98.          (setq m (list *g* m -1))
  99.          (if (null nl) (ncons (list *g* n 1 0 1))
  100.          (mapcar #'(lambda (p) (pabs (pcsubst p m (car p))))
  101.              (mapcar #'cyclotomic (divisors (reverse nl)))))))))
  102.  
  103.  
  104. (DEFUN CYCLP (N IND)
  105.   (SLOOP FOR I downFROM (f1- N) TO 0
  106.     NCONC (LIST (f* IND I) 1)))
  107.  
  108. (DEFUN CSF (L) 
  109.        (COND ((NULL L) NIL) (T (LIST* (CAR L) 1 (CSF (CDR L))))))
  110.  
  111. (DEFUN CONDENSE (L) 
  112.        (COND ((NULL (CDR L)) L)
  113.          ((EQ (CAR L) (CADR L)) (CONDENSE (CDR L)))
  114.          (T (CONS (CAR L) (CONDENSE (CDR L)))))) 
  115.  
  116. (DEFUN CYCLOTOMIC (NL) 
  117.   (PROG (N DP DPL NUM DEN P) 
  118.     (COND ((EQUAL 1 (CAR NL)) (RETURN (LIST *G* 1 1 0 -1)))
  119.           ((NULL (CDR (SETQ P (CONDENSE (CADR NL)))))
  120.            (RETURN (CONS *G*
  121.                  (CYCLP (CAR P)
  122.                     (EXPT (CAR P) (f1- (LENGTH (CADR NL)))))))))
  123.     (SETQ NUM 1 DEN 1 N (CAR NL) DPL (DIVISORS (CSF P)))
  124.    LOOP (COND ((NULL DPL) (RETURN (PQUOTIENT NUM DEN))))
  125.     (SETQ DP (CAR DPL))
  126.     (SETQ DPL (CDR DPL))
  127.     (SETQ P (LIST *G* (QUOTIENT N (CAR DP)) 1 0 -1))
  128.     (COND ((OR (EVENP (LENGTH (CADR DP))) (EQUAL (CAR DP) 1))
  129.            (SETQ NUM (PTIMES P NUM)))
  130.           (T (SETQ DEN (PTIMES P DEN))))
  131.     (GO LOOP))) 
  132.  
  133. (DEFUN DIVISORS (L)
  134.   (if (equal l '(1 1)) (setq l nil))
  135.   (do ((ans (LIST '(1 ()) ))
  136.        (l l (cddr l)))
  137.       ((null l) ans)
  138.     (do ((u ans)
  139.      (factor (car l))
  140.      (mult (cadr l) (f1- mult)))
  141.     ((zerop mult))
  142.       (SETQ U (MAPCAR #'(LAMBDA (Q) (LIST (TIMES factor (CAR Q))
  143.                       (CONS factor (CADR Q))))
  144.               U))
  145.       (SETQ ANS (NCONC ANS U)))))
  146.  
  147.  
  148. (DEFUN ESTCHECK2 (D LC C) 
  149.        (PROG (P) 
  150.     LOOP (COND ((NULL D) (RETURN NIL)))
  151.          (SETQ P (CAR D) D (CDR D))
  152.          (COND ((OR (AND (NOT (EQUAL (REMAINDER C P) 0))
  153.                  (NOT (EQUAL (REMAINDER LC (TIMES P P)) 0)))
  154.             (AND (NOT (EQUAL (REMAINDER LC P) 0))
  155.                  (NOT (EQUAL (REMAINDER C (TIMES P P)) 0))))
  156.             (RETURN T)))
  157.          (GO LOOP))) 
  158.  
  159. (DEFUN ESTCHECK (P) 
  160.        (PROG (LC C D) 
  161.          (COND ((OR (ATOM P) (NULL (CDDR P)) (EQUAL (PTERM P 0) 0))
  162.             (RETURN NIL)))
  163.          (SETQ LC (CADR P))
  164.          (SETQ P (NREVERSE (CDR (ODDELM (CDR P)))))
  165.          (SETQ C (CAR P))
  166.          (SETQ D (CGCDLIST P))
  167.          (COND ((EQUAL 1 D) (RETURN NIL)))
  168.          (SETQ D (ODDELM (CFACTORW D)))
  169.          (RETURN (ESTCHECK2 D LC C)))) 
  170.  
  171.  
  172. (DEFUN CGCDLIST (L) 
  173.        (COND ((NULL L) NIL)
  174.          ((NULL (CDR L)) (ABS (CAR L)))
  175.          ((OR (zl-MEMBER 1 L) (zl-MEMBER -1 L)) 1)
  176.          ((NULL (CDDR L)) (GCD (CAR L) (CADR L)))
  177.          (T (CGCDLIST (CONS (GCD (CAR L) (CADR L)) (CDDR L)))))) 
  178.  
  179. (DEFUN DROPTERMS (P) 
  180.        (PROG (ANS C) 
  181.          (COND ((ATOM P) (RETURN P))
  182.            ((NOT (EQ (CAR P) VAR)) (RETURN (KTERMS P DLP))))
  183.          (SETQ ANS (CONS (CAR P) ANS) P (CDR P))
  184.     LOOP (COND ((NULL P) (RETURN (COND ((CDR ANS) (NREVERSE ANS)) (T 0)))))
  185.          (SETQ C (KTERMS (CADR P) DLP))
  186.          (COND ((NOT (EQUAL C 0)) (SETQ ANS (CONS C (CONS (CAR P) ANS)))))
  187.          (SETQ P (CDDR P))
  188.          (GO LOOP))) 
  189.  
  190.  
  191. (DEFUN RESTORELC (L LC) 
  192.        (PROG (H R ANS VAR C D DEG) 
  193.          (COND ((EQUAL 1 LC)
  194.             (COND ((AND (NOT MANY*) ALGFAC* (NOT (EQUAL INTBS* 1)))
  195.                (RETURN (MAPCAR (FUNCTION INTBASEHK) L)))
  196.               (T (RETURN (REVERSE L))))))
  197.          (SETQ R (LCPRODL L) H 1)
  198.     LOOP (COND ((NULL L) (RETURN ANS)))
  199.          (SETQ D (CAR L) L (CDR L) VAR (CAR D) DEG (CADR D) C (CADDR D))
  200.          (SETQ D (PTIMES (PTIMES H (CAR R)) (PSIMP VAR (CDDDR D))))
  201.          (COND (MANY* (SETQ D (DROPTERMS D))))
  202.          (SETQ D (PPLUS (LIST VAR DEG LC)D))
  203.          (COND ((AND (NOT MANY*) ALGFAC* (NOT (EQUAL INTBS* 1)))
  204.             (SETQ D (INTBASEHK D))))
  205.          (LET ((MODULUS))
  206.           (SETQ ANS (CONS (CADR (OLDCONTENT D)) ANS)))
  207.          (SETQ H (PTIMES H C) R (CDR R))
  208.          (GO LOOP))) 
  209.  
  210. (DEFUN IREDUP (P)
  211.        (LET ((MM* 1) (ALGFAC*))
  212.         (COND ((SQFRP P(CAR P))
  213.            (SETQ P (CATCH 'SPLT (CPBER1 P)))
  214.            (AND (NULL (CAR P)) (NULL (CDADR P)))))))
  215.  
  216. (DEFUN ZEROLP (A) (ANDMAPC (FUNCTION ZEROP1) A))
  217.  
  218.  
  219. (DEFMFUN TESTDIVIDE (X Y) 
  220.   (LET ((ERRRJFFLAG T))
  221.     (COND (ALGFAC* (ALGTESTD X Y))
  222.       ((OR (PCOEFP X)
  223.            (PCOEFP Y)
  224.            (CATCH 'RATERR (PQUOTIENT (CAR (LAST X)) (CAR (LAST Y)))))
  225.        (CATCH 'RATERR (PQUOTIENT X Y))))))
  226.  
  227. (DEFUN ALGTESTD (X Y)
  228.   (AND (DIV-DEG-CHK (NREVERSE (PDEGREEVECTOR X)) (NREVERSE (PDEGREEVECTOR Y))
  229.             (REVERSE GENVAR))
  230.        (COND ((SETQ X (CATCH 'RATERR (RQUOTIENT X Y)))
  231.           (SETQ ADN* (f* ADN* (CDR X)))
  232.           (CAR X)) )))
  233.  
  234. (DEFUN DIV-DEG-CHK (XL YL GL)
  235.   (COND ((OR (NULL GL) (ALGV (CAR GL))) T)
  236.     ((> (CAR YL) (CAR XL)) NIL)
  237.     (T (DIV-DEG-CHK (CDR XL) (CDR YL) (CDR GL)))))
  238.  
  239. ; FUU is used by systems programmers such as BMT and PAULW while debugging.
  240. (DEFUN FUU NIL 
  241.        (SETQ TELLRATLIST NIL VARLIST NIL GENVAR NIL GENPAIRS NIL)) 
  242.  
  243. (DEFUN LINOUT (U) 
  244.        (PROG (M LINFAC X Y) 
  245.          (SETQ Y (LIST (SETQ X (CAR U)) 1 1) M MODULUS)
  246.     LOOP (SETQ M (f1- M))
  247.          (COND ((LESSP M 0) (RETURN (LIST U LINFAC)))
  248.            ((EQUAL (CADR U) 1) (RETURN (LIST 1 (CONS U LINFAC))))
  249.            ((ZEROP (PCSUBSTY (CMOD M) X U))
  250.             (SETQ LINFAC
  251.               (CONS (APPEND Y
  252.                     (COND ((ZEROP M) NIL)
  253.                           (T (LIST 0 (CMOD (f- M))))))
  254.                 LINFAC))
  255.             (SETQ U (CAR (PMODQUO U (CAR LINFAC))))))
  256.          (GO LOOP))) 
  257.  
  258. (DEFUN ONEVARP (P) 
  259.   (IF ALGFAC* (ANDMAPC #'PACOEFP (CDR P))
  260.       (ANDMAPC #'NUMBERP (CDR P)))) 
  261.  
  262. (DEFUN PUTODR (L)
  263.        (DO ((L L (CDR L))
  264.         (I 1 (f1+ I))
  265.         (ANS))
  266.        ((NULL L) ANS)
  267.        (PUSH (CONS (CAR L) I) ANS)))
  268.  
  269. (DEFUN KTERMS (P K) 
  270.        (DECLARE (FIXNUM K))
  271.        (COND ((PACOEFP P) P)
  272.          ((= K 0) (CONSTA P))
  273.          (T (PROG (V ANS W) 
  274.               (SETQ V (CAR P))
  275.               (SETQ P (CDR P))
  276.          LOOP (COND ((NULL P) (RETURN 0))
  277.                 ((> (CAR P) K) (SETQ P (CDDR P)) (GO LOOP)))
  278.          AG   (COND ((NULL P)
  279.                  (RETURN (PSIMP V ANS))))
  280.               (SETQ W (KTERMS (CADR P) (f- K  (CAR P))))
  281.               (COND ((NOT (PZEROP W))
  282.                  (SETQ ANS (NCONC ANS (LIST (CAR P) W)))))
  283.               (SETQ P (CDDR P))
  284.               (GO AG))))) 
  285.  
  286. (DEFUN CONSTA (P)
  287.        (COND ((OR (PCOEFP P) (ALG P)) P)
  288.          (T (CONSTA (PTERM (CDR P) 0)))))
  289.  
  290. (DEFUN CONSTACL (P)    ;NO LONGER USED?
  291.        (COND ((ATOM P)
  292.           (COND ((EQUAL P 1) (THROW 'CNT 1))
  293.             (T (LIST P))))
  294.          ((ANDMAPC 'NUMBERP (CDR P))
  295.           (SETQ P (ODDELM P))
  296.           (COND ((zl-MEMBER 1 P) (THROW 'CNT 1))
  297.             (T (CDR P))))
  298.          (T (APPLY (FUNCTION APPEND)
  299.                (MAPCAR (FUNCTION CONSTACL) (CDR (ODDELM P)))))))
  300.  
  301. (DEFUN Z1 (POLY FACT1 FACT2) 
  302.     #-cl       (DECLARE(FIXNUM STEPS STEP HSTEPS))
  303.   (PROG (RES HSTEPS STEPS KTERM A B C D *AB* M DF1 DF2 DLR STEP *SHARPA *SHARPB)
  304.     (LET ((MODULUS) (HMODULUS))
  305.          (SETQMODULUS *PRIME)
  306.          (SETQ *SHARPB (FACT20 FACT1 FACT2 LIMK)))
  307.     (SETQ *SHARPA (CAR *SHARPB))
  308.     (SETQ *SHARPB (CADR *SHARPB))
  309.     (SETQ *AB* (LIST (LIST 0 *SHARPA *SHARPB)))
  310.     (SETQ STEPS DLP 
  311.           HSTEPS (// STEPS 2))
  312.     (SETQ RES (PDIFFERENCE (PTIMES (PMOD FACT1) (PMOD FACT2)) (PMOD POLY)))
  313.     (SETQ POLY NIL)
  314.     (SETQ STEP 0)
  315.     (SETQ DF1 FACT1)
  316.     (SETQ DF2 FACT2)
  317.    LOOP (COND ((EQUAL RES 0) (GO OUT)))
  318.     (SETQ STEP (f1+ STEP))
  319.     (COND ((GREATERP STEP STEPS) (GO OUT)))
  320.     (COND ((EQ (CAR RES) VAR) (SETQ C (CDR RES)))
  321.           (T (SETQ C (LIST 0 RES))))
  322.     (SETQ A 0 B 0)
  323.   NEXTM (COND ((NULL C) (Z2 A B STEP HSTEPS) (GO LOOP)))
  324.     (SETQ M (CAR C) DLR (CADR C))
  325.     (SETQ C (CDDR C))
  326.     (SETQ KTERM (KTERMS DLR STEP) DLR NIL)
  327.     (COND ((EQUAL 0 KTERM) (GO NEXTM)))
  328.     (SETQ D (OBTAINABM M))
  329.     (SETQ B (PPLUS B (PTIMES (CAR D) KTERM)) 
  330.           A (PPLUS A (PTIMES (CADR D) KTERM)) 
  331.           KTERM NIL)
  332.     (GO NEXTM)
  333.    OUT  (RETURN (LIST DF1 DF2)))) 
  334.  
  335. (DEFUN Z2 (A B STEP HSTEPS)
  336.  (UNLESS (AND (EQUAL A 0) (EQUAL B 0))
  337.      (SETQ STEP
  338.            (PDIFFERENCE
  339.         (PDIFFERENCE (COND ((NOT (LESSP STEP HSTEPS))
  340.                     (DROPTERMS (PTIMES A B)))
  341.                    (T (PTIMES A B)))
  342.                  (COND ((NOT (LESSP STEP HSTEPS))
  343.                     (DROPTERMS (PTIMES DF1 B)))
  344.                    (T (PTIMES DF1 B))))
  345.         (COND ((NOT (LESSP STEP HSTEPS))
  346.                (DROPTERMS (PTIMES DF2 A)))
  347.               (T (PTIMES DF2 A)))))
  348.      (SETQ RES (PPLUS RES STEP))
  349.      (SETQ DF1 (PDIFFERENCE DF1 A))
  350.      (SETQ DF2 (PDIFFERENCE DF2 B))))
  351.  
  352. (DEFUN OBTAINABM (M) 
  353.        (PROG (ANS) 
  354.          (COND ((SETQ ANS (CDR (zl-ASSOC M *AB*))) (RETURN ANS)))
  355.          (SETQ ANS (OBTAINAB (LIST VAR M 1)))
  356.          (SETQ *AB* (CONS (CONS M ANS) *AB*))
  357.          (RETURN ANS))) 
  358.  
  359. (DEFUN FACT20 (F1 G1 LIMK) 
  360.        (PROG (F G A PK B REML QLP H K B1) 
  361.          (SETQ K 0)
  362.          (SETQ REML (PPPROG (PMOD F1) (PMOD G1)))
  363.          (SETQ A (CAR REML))
  364.          (SETQ B (CADR REML))
  365.     SHARP   (COND ((GREATERP K LIMK) (RETURN (LIST A B))))
  366.          (SETQ PK MODULUS)
  367.          (SETQMODULUS (TIMES MODULUS MODULUS))
  368.          (SETQ F(PMOD F1) G (PMOD G1))
  369.          (SETQ H (PQUO (PMOD (PDIFFERENCE (PPLUS (PTIMES A F) (PTIMES B G))
  370.                           1))
  371.                PK))
  372.          (SETQ QLP (PMODQUO (PTIMES A H) G))
  373.          (SETQ B1 (PPLUS (PTIMES B H) (PTIMES (CAR QLP) F)))
  374.          (SETQ A (PDIFFERENCE A (PMOD (PCTIMES PK (CDR QLP)))))
  375.          (SETQ B (PDIFFERENCE B (PMOD (PCTIMES PK B1))))
  376.          (SETQ K (f1+ K))
  377.          (GO SHARP))) 
  378.  
  379.  
  380.  
  381. (DEFUN BASELIST (N) (SETQ *I* N) (COMPLETEVECTOR NIL 0 N ELM)) 
  382.  
  383. (DEFUN INLIST3 (L) 
  384.        (COND ((NULL L) (SETQ *INL3 NIL))
  385.          ((ZEROP (CAR L)) (CONS 1 (CDR L)))
  386.          ((EQUAL (CAR L) 1) (CONS -1 (CDR L)))
  387.          (T (CONS 0 (INLIST3 (CDR L)))))) 
  388.  
  389. (DEFUN NEWREP (P) 
  390.        (LET ((MODULUS))
  391.         (IF SUBVAR (PCSUBSTY (MAPCAR #'(LAMBDA (A B) (LIST A 1 1 0 B))
  392.                      SUBVAR SUBVAL)
  393.                  SUBVAR
  394.                  P)
  395.         P)))
  396.  
  397. (DEFUN OLDREP (P) 
  398.    (LET ((MODULUS))
  399.     (IF SUBVAR (PCSUBSTY (MAPCAR #'(LAMBDA (A B) (LIST A 1 1 0 (MINUS B)))
  400.                      SUBVAR SUBVAL)
  401.                  SUBVAR
  402.                  P)
  403.         P)))
  404.  
  405. (DEFUN COMPLETEVECTOR (L N M V)
  406.        (DO ((I M (f1- I)))
  407.        ((= I N) L)
  408.        (PUSH V L))) 
  409.  
  410. (DEFUN DEGVECTOR (L N C) 
  411.        (PROG (LF ANS J) 
  412.          BK (COND ((NUMBERP C)
  413.             (RETURN  (LIST (COMPLETEVECTOR L N NN* 0)))))
  414.          (SETQ J (CDR (zl-ASSOC (CAR C) *ODR*)))
  415.          ;;; IN CASE (CAR C) IS ALGEBRAIC
  416.              (COND ((NULL J) (SETQ C 0)(GO BK)))    
  417.          (SETQ C (CDR C))
  418.          (SETQ LF (COMPLETEVECTOR L N J 0))
  419.     LOOP (COND ((NULL C) (RETURN ANS)))
  420.          (SETQ ANS
  421.            (NCONC (DEGVECTOR (CONS (CAR C) LF) (f1+ J) (CADR C)) ANS))
  422.          (COND (*MX* (SETQ ANS (NCONS (MAXLIST ANS))))
  423.            (*MIN* (SETQ ANS (NCONS (MINLIST ANS)))))
  424.              (SETQ C (CDDR C))
  425.              (GO LOOP)))
  426.  
  427. (DEFUN UNION1 (A B)
  428.        (DO ((A A (CDR A))
  429.         (ANS B))
  430.        ((NULL A) ANS)
  431.        (OR (zl-MEMBER (CAR A) ANS)
  432.            (SETQ ANS (CONS (CAR A) ANS)))))
  433.  
  434. (DEFUN OBTAINAB (U) 
  435.        (PROG (C QL)
  436.          (SETQ C (PMOD U))
  437.          (SETQ QL (PMODQUO (PTIMES *SHARPA C) FACT2))
  438.          (RETURN (LIST (CDR QL) (PMOD (PPLUS (PTIMES (CAR QL) FACT1)
  439.                          (PTIMES *SHARPB C)))))))
  440.  
  441.  
  442.  
  443. (DEFUN PCDIFCONC (V J)
  444.        (DO ((L V (CDDR L)))
  445.        ((NULL (CDR L))
  446.         (OR (= J 0)
  447.         (RPLACD L (LIST 0 J)))
  448.         V)
  449.        (COND ((= (CADR L) 0)
  450.           (COND ((= J 0)
  451.              (RPLACD L NIL))
  452.             ((RPLACA (CDDR L) J)))
  453.           (RETURN V))))) 
  454.  
  455. (DEFUN ORDE (A L) 
  456.        (COND ((NULL L) (LIST A))
  457.          (T (COND ((LESSP A (CAR L)) (CONS A L))
  458.               (T (CONS (CAR L) (ORDE A (CDR L)))))))) 
  459.  
  460. (DEFUN PQUO (X Y) (LET (MODULUS) (PQUOTIENT X Y))) 
  461.  
  462. (DEFUN INTERSECT (X Y) 
  463.   (IF X (IF (zl-MEMBER (CAR X) Y) (CONS (CAR X) (INTERSECT (CDR X) Y))
  464.                    (INTERSECT (CDR X) Y))))
  465.  
  466. ;; Like APL IOTA function.
  467. (DEFUN INDEX* (K) 
  468.   (DECLARE (FIXNUM K))
  469.   (IF (< K 2) (LIST 1) (CONS K (INDEX* (f1- K)))))
  470.  
  471.  
  472. (DEFUN KLIM (U P1) 
  473.        (PROG (BCOEF) 
  474.          (SETQ BCOEF (MAXCOEFFICIENT U))
  475.          (SETQ BCOEF (TIMES 5 BCOEF))
  476.          (COND (ALGFAC* (SETQ BCOEF (TIMES BCOEF INTBS*))))
  477.           (COND ((LESSP BCOEF 10000.) (SETQ BCOEF 20000.)))
  478.          (SETQ LIMK 0)
  479.     TEST (SETQ P1 (TIMES P1 P1))
  480.          (COND ((GREATERP P1 BCOEF)
  481.             (SETQ PLIM P1)
  482.             (RETURN LIMK)))
  483.          (SETQ LIMK (f1+ LIMK))
  484.          (GO TEST))) 
  485.  
  486. (DECLARE-TOP(SPECIAL B B2)) 
  487.  
  488. (DEFUN CPBERL (U) 
  489.        (PROG (QL D) 
  490.          (SETQ QL (CATCH 'SPLT (CPBER1 U)) U (CADDR QL))
  491.          (SETQ D (CAR QL) QL (CADR QL))
  492.          (COND ((NULL QL)(RETURN D))
  493.            ((NULL (CDR QL)) (RETURN (CONS U D))))
  494.          (RETURN (APPEND D 
  495.                  (COND ((OR ALPHA (GREATERP MODULUS 70.))
  496.                     (CPBGZASS QL (PMOD U) (LENGTH QL)))
  497.                    (T (CPBG QL (PMOD U) (LENGTH QL))))))))
  498.  
  499. ;; Returns a list of monomials in G of degree less than N.
  500. (DEFUN POWRS (G N &AUX (ANS (NCONS 1)))
  501.   (DECLARE (FIXNUM N))
  502.   (DO ((I 1 (f1+ I))) ((= I N) ANS)
  503.     (DECLARE (FIXNUM I))
  504.     (PUSH (MAKE-POLY G I 1) ANS)))
  505.  
  506.  
  507. ;; Finds polynomials A and B such that A*F+B*G=1 when MODULUS
  508. ;; is non-NIL.  Same algorithm as INVMOD.
  509. (DEFUN PPPROG (F G) 
  510.   (PROG (A1 A2 B1 B2 R1 R2 QL ANS AP BP G1 F1 S) 
  511.     (COND ((GREATERP (CADR G) (CADR F)) (SETQ G1 G) (SETQ F1 F))
  512.           (T (SETQ G1 F) (SETQ F1 G) (SETQ S T)))
  513.     (SETQ QL (PMODQUO G1 F1))
  514.     (SETQ A1 1)
  515.     (SETQ B1 0)
  516.     (SETQ A2 (PMINUS (CAR QL)))
  517.     (SETQ B2 1)
  518.     (SETQ R1 F1)
  519.     (SETQ R2 (CDR QL))
  520.    TEST (COND ((OR (NUMBERP R2) (AND ALPHA (ALG R2))) (GO END)))
  521.     (SETQ QL (PMODQUO R1 R2))
  522.     (SETQ AP (PDIFFERENCE A1 (PTIMES (CAR QL) A2)))
  523.     (SETQ BP (PDIFFERENCE B1 (PTIMES (CAR QL) B2)))
  524.     (SETQ R1 R2)
  525.     (SETQ R2 (CDR QL))
  526.     (SETQ A1 A2)
  527.     (SETQ B1 B2)
  528.     (SETQ A2 AP)
  529.     (SETQ B2 BP)
  530.     (GO TEST)
  531.    END  (COND ((PZEROP R2)
  532.            (COND ((EQUAL 1 (SETQ ANS (CADDR R1)))
  533.               (SETQ ANS (LIST B1 A1)))
  534.              (T (SETQ ANS (LIST (CAR (PMODQUO B1 ANS))
  535.                     (CAR (PMODQUO A1 ANS))))))
  536.            (GO OUT)))
  537.         (SETQ ANS (LIST (CAR (PMODQUO B2 R2)) (CAR (PMODQUO A2 R2))))
  538.    OUT  (COND ((NOT S) (RETURN (REVERSE ANS))) (T (RETURN ANS))))) 
  539.  
  540.  
  541. (DEFUN ZFF (V F G) (COND (MANY* (Z1 V F G)) (T (FACT2Z V F G LIMK)))) 
  542.  
  543. (DEFUN ZFACT (U FL LIMK MANY*) 
  544.   (PROG (FCS* PRODL) 
  545.     (COND (MANY* (SETQMODULUS PLIM)
  546.              (SETQ DLP
  547.                (EVAL (CONS 'MAX
  548.                        (MAPCAR (FUNCTION MULTIDEG)
  549.                            (CDR (ODDELM U))))))))
  550.     (COND ((EQUAL (LENGTH FL) 1) (RETURN (LIST U))))
  551.     (SETQ PRODL (FSPLIT FL 'V))
  552.     (ZFACTSPLIT PRODL U)
  553.     (RETURN FCS*))) 
  554.  
  555. (DEFUN ZFACTSPLIT (FL V) 
  556.   (PROG (D) 
  557.     (COND ((NULL (CDR FL)) (RETURN (SETQ FCS* (CONS V FCS*))))
  558.           ((NULL (CDDR FL))
  559.            (SETQ FL (CADR FL))
  560.            (RETURN (SETQ FCS* (NCONC (ZFF V (CAR FL) (CADR FL)) FCS*))))
  561.           (T (SETQ FL (CDR FL))
  562.          (SETQ D (ZFF V (CAAR FL) (CAADR FL)))
  563.          (SETQ V NIL)
  564.          (ZFACTSPLIT (CAR FL) (CAR D))
  565.          (RETURN (ZFACTSPLIT (CADR FL) (CADR D))))))) 
  566.  
  567. (DEFUN SPLIT2 (L) 
  568.        (PROG (S N) 
  569.          (SETQ N (QUOTIENT (LENGTH L) 2))
  570.          (SETQ S (NCDR L N))
  571.          (SETQ DN* (COPY1 (CDR S)))
  572.          (RPLACD S NIL)
  573.          (SETQ NN* L))) 
  574.  
  575. (DEFUN FSPLIT (L IND) 
  576.        (PROG (NN* DN*) 
  577.          (COND ((NULL (CDR L)) (RETURN L))
  578.            ((NULL (CDDR L))
  579.             (RETURN (LIST (APPLY (FUNCTION PTIMES) L) L))))
  580.          (SPLIT2 L)
  581.          (SETQ NN* (FSPLIT NN* NIL))
  582.          (SETQ DN* (FSPLIT DN* NIL))
  583.          (RETURN (LIST (COND (IND IND) (T (PTIMES (CAR NN*) (CAR DN*))))
  584.                NN*
  585.                DN*)))) 
  586.  
  587. ;Definition is identical to HAULONG.
  588. ;(DEFUN BOUNDFUN (N) (f1+ (LOG2 N))) 
  589.  
  590. (COMMENT THIS PAGE CONTAINS ROUTINES CHANGED FOR NON-MONIC HACK)
  591.  
  592. (DEFUN PEXPTMOD (P N Q) 
  593.        (PROG (U X) 
  594.          (COND ((PCOEFP P) (RETURN (CEXPT P N))))
  595.          (SETQ Q (CDR Q) X (CAR P))
  596.          (COND   ((ODDP N) (SETQ P(SETQ U (PGCD1 (CDR P) Q)))(GO B))
  597.            (T (SETQ U '(0 1))))
  598.          (SETQ P (CDR P))
  599.     A    (SETQ P (PGCD1 P Q))
  600.     B    (SETQ N (QUOTIENT N 2))
  601.          (COND ((EQUAL 0 N) (RETURN (CONS X U))))
  602.          (SETQ P (PTIMES1 P P))
  603.          (COND ((ODDP N) (SETQ U (PGCD1 (PTIMES1 U P) Q))))
  604.          (GO A)))
  605.  
  606. (DEFUN SQFRP (U VAR) 
  607.        (COND ((AND (EQUAL 0 (PTERM (CDR U) 0)) (EQUAL 0 (PTERM (CDR U) 1)))
  608.           NIL)
  609.          ((ONEVARP U)
  610.           (SETQ U (PGCD U (PDERIVATIVE U VAR)))
  611.           (OR (NUMBERP U) (ALG U)))
  612.          (T (QUICK-SQFR-CHECK U VAR)))) 
  613.  
  614. (DEFUN LOGTWO (X) 
  615.        (PROG (ANS) 
  616.          (COND ((EQUAL X 0) (RETURN 0)) ((EQUAL X 1) (RETURN 1)))
  617.          (SETQ ANS (LOG2 X))
  618.          (COND ((GREATERP X (EXPT 2 ANS)) (RETURN (f1+ ANS)))
  619.            (T (RETURN ANS))))) 
  620.  
  621. (DECLARE-TOP(SPECIAL P)) 
  622.  
  623. (DEFUN FIXVL0 (L1 L2 OV) 
  624.        (PROG (A B C) 
  625.     LOOP (COND ((NULL OV) (SETQ SUBVAR A SUBVAL B VALIST C) (RETURN NIL))
  626.            ((MEMQ (CAR OV) L1)
  627.             (SETQ A (CONS (CAR OV) A) 
  628.               B (CONS (ASSSO (CAR OV) L1 L2) B) 
  629.               C (CONS (CAR B) C)))
  630.            (T (SETQ C (CONS 0 C))))
  631.          (SETQ OV (CDR OV))
  632.          (GO LOOP))) 
  633.  
  634. (DEFUN ASSSO (A L1 L2) 
  635.        (PROG NIL 
  636.     LOOP (COND ((NULL L1) (RETURN NIL)) ((EQ (CAR L1) A) (RETURN (CAR L2))))
  637.          (SETQ L1 (CDR L1) L2 (CDR L2))
  638.          (GO LOOP))) 
  639.  
  640. (DEFUN ZEROHK (L) 
  641.        (PROG (ANS I) 
  642.          (COND ((NULL L) (RETURN NIL)))
  643.     AG   (SETQ ANS (CAR L) I (ZEROSHARP ANS))
  644.     LOOP (SETQ L (CDR L))
  645.          (COND ((NULL L) (RETURN ANS))
  646.            ((GREATERP (ZEROSHARP (CAR L)) I) (GO AG)))
  647.          (GO LOOP))) 
  648.  
  649.  
  650. (DEFUN MULTFACT (POLY) 
  651.        (PROG (*INL3 *I* *MIN* *MX* NN* *ODR* LC ELM LISTELM PLIM ORIGENVAR NE VAR VALIST VAL1
  652.           OVARLIST P SUBVAR SUBVAR1 SUBVAL1 SUBVAL DLP)
  653. ;         (declare (special p))
  654.          (SETQ VAR (CAR POLY) ELM (LISTOVARS POLY) 
  655.            ORIGENVAR GENVAR 
  656.            GENVAR (INTERSECT GENVAR (COND (ALGFAC* (zl-DELETE (CAR ALPHA) ELM))(T ELM))) 
  657.            OVARLIST (REVERSE (CDR (REVERSE GENVAR))) 
  658.            NN* (f1+ (LENGTH OVARLIST)))
  659.          (SETQ LISTELM 0)
  660.          (SETQ LC (CADDR POLY))
  661.          (SETQ ELM 1 *I* 1 NE 1)
  662.          (SETQ SUBVAL (REVERSE POLY))
  663.          (SETQ *ODR*(PUTODR (REVERSE OVARLIST)))
  664.          (SETQ VAL1
  665.            (ZEROHK (NCONC (DEGVECTOR NIL 1 LC)
  666.                   (COND ((OR (GREATERP (CADR SUBVAL) 0)
  667.                          (GREATERP (CADDDR SUBVAL) 1))
  668.                      (DEGVECTOR NIL 1 (CAR SUBVAL)))))))
  669.          (SETQ SUBVAL NIL)
  670.          (SETQ P POLY)
  671.          (COND ((NULL VAL1)
  672.             (SETQ SUBVAR1 OVARLIST)
  673.             (SETQ SUBVAL1 (POLYSUBST (NZEROS (LENGTH SUBVAR1) NIL)
  674.                          SUBVAR1))
  675.             (GO TAG)))
  676.          (FIXVL VAL1 OVARLIST)
  677.          (FIXVL1 VAL1 OVARLIST)
  678.          (COND (SUBVAL1 (SETQ SUBVAL1 (POLYSUBST SUBVAL1 SUBVAR1))))
  679.          (SETQ SUBVAL
  680.            (POLYSUBST (COMPLETEVECTOR NIL 0 (LENGTH SUBVAL) 1)
  681.                   SUBVAR))
  682.     TAG  (FIXVL SUBVAL1 SUBVAR1)
  683.          (SETQ SUBVAL1 NIL SUBVAR1 NIL)
  684.          (FIXVL0 SUBVAR SUBVAL (REVERSE OVARLIST))
  685.          (COND (ALGFAC* (SETQ GENVAR (CONS (CAR ALPHA) GENVAR))))
  686.          (SETQ POLY (CPBER3 POLY P))
  687.          (SETQ GENVAR ORIGENVAR)
  688.          (RETURN POLY))) 
  689.  
  690. (DEFUN POLYSUBST (A B)
  691. ;  (declare (special p))
  692.        (PROG (LC *INL3 D N MODULUS) 
  693.          (COND (MODULU* (SETQ MODULUS MODULU*)))
  694.          (SETQ *INL3 T LC (CADDR P) N (LENGTH A))
  695.     LOOP (SETQ D (PCSUBSTY A B LC))
  696.          (COND ((EQUAL 0 D) (GO INL)))
  697.          ((LAMBDA (MODULUS) (SETQ D (PCSUBSTY A B P))) NIL)
  698.          (COND ((SQFRP (PMOD D) (CAR D)) (SETQ P D) (RETURN A)))
  699.     INL  (SETQ A (INCREASELIST A N))
  700.          (GO LOOP))) 
  701.  
  702. (DECLARE-TOP (UNSPECIAL P)) 
  703.  
  704. (DEFUN ZEROSHARP (L)
  705.        (DO ((N 0) (L L (CDR L)))
  706.        ((NULL L) N)
  707.        (IF (ZEROP (CAR L)) (SETQ N (f1+ N))))) 
  708.  
  709. (DEFUN FIXVL1 (L R) 
  710.        (PROG NIL 
  711.     LOOP (COND ((NULL L)
  712.             (SETQ SUBVAL1 (NREVERSE SUBVAL1) SUBVAR1 (NREVERSE SUBVAR1))
  713.             (RETURN NIL))
  714.            ((ZEROP (CAR L))
  715.             (SETQ SUBVAL1 (CONS (CAR L) SUBVAL1))
  716.             (SETQ SUBVAR1 (CONS (CAR R) SUBVAR1))))
  717.          (SETQ L (CDR L))
  718.          (SETQ R (CDR R))
  719.          (GO LOOP))) 
  720.  
  721. (DEFUN FIXVL (L R) 
  722.        (PROG NIL 
  723.     LOOP (COND ((NULL L)
  724.             (SETQ SUBVAL (NREVERSE SUBVAL) SUBVAR (NREVERSE SUBVAR))
  725.             (RETURN NIL))
  726.            ((NOT (ZEROP (CAR L)))
  727.             (SETQ SUBVAL (CONS (CAR L) SUBVAL))
  728.             (SETQ SUBVAR (CONS (CAR R) SUBVAR))))
  729.          (SETQ L (CDR L))
  730.          (SETQ R (CDR R))
  731.          (GO LOOP))) 
  732.  
  733. (DEFUN LOGN (ARG N) 
  734.        (COND ((GREATERP ARG N) (f1+ (LOGN (QUOTIENT ARG N) N))) (T 0))) 
  735.  
  736. (DEFUN MAXCOEF (P) (MAXCOEFFICIENT P)) 
  737.  
  738. (DEFUN INCRLIMK (P) 
  739.        (PROG (V) 
  740.          (COND (MODULU* (SETQ PLIM MODULU* *PRIME MODULU* LIMK -1) (RETURN NIL))
  741.            ((NULL LIMK)(SETQ PLIM *ALPHA *PRIME *ALPHA LIMK -1)(RETURN NIL)))
  742.          (SETQ V (NREVERSE (CDR (REVERSE (PDEGREEVECTOR P)))))
  743.          (SETQ V
  744.            (APPLY
  745.             '*
  746.             (MAPCAR 
  747.         (FUNCTION
  748.          (LAMBDA (A B) 
  749.              (COND ((EQUAL B 0) 1)
  750.                    (T (MAX (TIMES (SIMPBINOCOEF (LIST '(%BINOCOEF)
  751.                                   A
  752.                                   (QUOTIENT A
  753.                                         2))
  754.                                 1
  755.                                 T)
  756.                           (EXPT B (QUOTIENT A 2)))
  757.                        (EXPT B A))))))
  758.         V
  759.         VALIST)))
  760.          (SETQ V(MAX 0 (f1- (LOGTWO (LOGN (TIMES (MAX (MAXCOEF P) PLIM) V) PLIM)))))
  761.          (SETQ LIMK (f+ LIMK V))
  762.     LOOP (COND ((< V 1) (RETURN NIL)))
  763.          (SETQ V (f1- V))
  764.          (SETQ PLIM (TIMES PLIM PLIM))
  765.          (GO LOOP))) 
  766.  
  767.  
  768.  
  769. (DEFUN INCREASELIST (L N) 
  770.   (COND (*INL3 (SETQ L (INLIST3 L))))
  771.   (COND (*INL3 L)
  772.     (T (COND ((EQUAL ELM 2)
  773.           (COND (MODULU*
  774.              (MERROR "Not enough choices for substitution."))
  775.             (T (RAND N 13.))))
  776.          ((EQUAL NE N)
  777.           (SETQ ELM (f1+ ELM))
  778.           (SETQ NE 1)
  779.           (COMPLETEVECTOR (BASELIST NE) NE N LISTELM))
  780.          (T (COND ((EQUAL *I* N)
  781.                (SETQ NE (f1+ NE))
  782.                (COMPLETEVECTOR (BASELIST NE) NE N LISTELM))
  783.               (T (SETQ *I* (f1+ *I*))
  784.                  (REVERSE (CDR (REVERSE (CONS LISTELM
  785.                               L))))))))))) 
  786.  
  787.  
  788. ;; Returns a list of N random numbers.  If MODULUS is set, then the
  789. ;; numbers will be modulo MODULUS.   Otherwise, between 0 and 1000.
  790. (DEFUN RAND (N MODULUS)
  791.   (declare (fixnum n))
  792.   (DO ((I N (f1- I)) (L))
  793.       ((= I 0) (COND (MODULUS (MAPCAR #'CMOD L))
  794.              (T L)))
  795.       (DECLARE (FIXNUM I))
  796.     (PUSH (RANDOM 1000.) L)))
  797.  
  798. (DEFUN TRUFAC (V LP OLFACT MANY* MODULUS) 
  799.        (PROG (ANS OLC LC AF QNT FACTOR LFUNCT HMODULUS) 
  800.          (SETQ LC 1 OLC 1)
  801.          (SETQMODULUS MODULUS)
  802.          (SETQ LFUNCT (SETQ OLFACT (CONS NIL OLFACT)))
  803.     TEST (COND
  804.           ((EQUAL V 1) (SETQ ANS FACTOR) (GO OUT))
  805.           ((NULL LP)
  806.            (SETQ 
  807.         ANS
  808.         (COND ((LESSP (LENGTH OLFACT) 4) (CONS V FACTOR))
  809.               (T (NCONC FACTOR
  810.                 (NPROD LC
  811.                        V
  812.                        (CONS ((LAMBDA (MODULUS) 
  813.                               (PTIMES OLC
  814.                                   (CADR OLFACT)))
  815.                           PLIM)
  816.                          (CDDR OLFACT)))))))
  817.            (GO OUT))
  818.           ((AND (NULL (CDR LP)) (OR (NULL (CDR OLFACT)) (NULL (CDDR OLFACT))))
  819.            (SETQ ANS (CONS V FACTOR))
  820.            (GO OUT)))
  821.          (SETQ AF (CAR LP))
  822.          (COND ((SETQ QNT ((LAMBDA (MODULUS) (TESTDIVIDE V AF)) MODULU*))
  823.             (SETQ FACTOR (CONS AF FACTOR))
  824.             (SETQ LC (PTIMES LC (CADDR AF)))
  825.             (SETQ V QNT)
  826.             ((LAMBDA (MODULUS) 
  827.                  (SETQ OLC (PTIMES (CADDR (CADR LFUNCT)) OLC)))
  828.              PLIM)
  829.             (RPLACD LFUNCT (CDDR LFUNCT)))
  830.            (T (SETQ LFUNCT (CDR LFUNCT))))
  831.          (SETQ LP (CDR LP))
  832.          (GO TEST)
  833.     OUT  (RETURN ANS))) 
  834.  
  835. (DEFUN MULTIDEG (P) 
  836.        (PROG (M D) 
  837.          (COND ((NUMBERP P) (RETURN 0)) ((ONEVARP P) (RETURN (CADR P))))
  838.          (SETQ P (CDR P) M (CAR P))
  839.     LOOP (COND ((NULL P) (RETURN M)))
  840.          (SETQ D (PLUS (CAR P) (MULTIDEG (CADR P))) P (CDDR P) M (MAX D M))
  841.          (GO LOOP))) 
  842.  
  843. (DEFUN ODDELM (L) 
  844.        (PROG (ANS) 
  845.     LOOP (COND ((NULL L) (RETURN (NREVERSE ANS)))
  846.            ((NULL (CDR L)) (RETURN (NREVERSE (CONS (CAR L) ANS)))))
  847.          (SETQ ANS (CONS (CAR L) ANS) L (CDDR L))
  848.          (GO LOOP))) 
  849.  
  850.  
  851.  
  852.  
  853. (DEFUN CPBER3 (V U) 
  854.        (PROG (FACTZ ALCINV LC PLIM MONIC* SHARPCONT LIMK VAR VFACT) 
  855.          (SETQ VAR (CAR U))
  856.          (COND ((AND ALGFAC* (NOT (ATOM (CADDR U))))
  857.             (SETQ ALC (CADDR U))
  858.             (SETQ U (PTIMES U (CAR(SETQ ALCINV(RAINV ALC))) ))
  859.             (SETQ V (PTIMES V (CAR ALCINV)))
  860.             (SETQ ADN* (TIMES ADN* (CDR ALCINV)))))
  861.          (SETQ U (OLDCONTENT U))
  862.          (SETQ SHARPCONT (CAR U) U (CADR U))
  863.          (SETQ LC (CADDR V))
  864.          (COND ((EQUAL LC 1) (SETQ MONIC* T)))
  865.          (SETQ FACTZ (FACT5 U))
  866. (COMMENT THIS IS THE BARRY TRICK)
  867.              (COND (*STOP* (SETQ *STOP* PLIM) (RETURN (CONS (CAR SUBVAL)  FACTZ))))
  868.          (SETQ U NIL)
  869.          (COND ((NULL (CDR FACTZ)) (RETURN (LIST V)))
  870.            ((AND ALGFAC* (NOT (EQUAL ADN* 1)))
  871.             (SETQ V (PCTIMES ADN* V) LC (PCTIMES ADN* LC))))
  872.          (INCRLIMK V)
  873.          (SETQ MODULUS PLIM)
  874.          (SETQ U V V (NEWREP V))
  875.          (COND ((NUMBERP (CAR FACTZ))
  876.             (SETQ SHARPCONT (PTIMES SHARPCONT (CAR FACTZ)) FACTZ (CDR FACTZ))))
  877.          (COND ((NOT (EQUAL SHARPCONT 1))
  878.             (SETQ FACTZ (CONS (PTIMES SHARPCONT (CAR FACTZ)) (CDR FACTZ)))))
  879.          (SETQ VFACT (ZFACT V FACTZ LIMK T))
  880.  
  881.          (SETQ FACTZ (COND (MONIC* (REVERSE VFACT))
  882.                    (T (RESTORELC VFACT (NEWREP LC)))))
  883.              (COND ((AND ALGFAC* (NOT (EQUAL ADN* 1)))
  884.             (SETQ V (PCTIMES (CRECIP ADN*) V))(SETQ ADN* 1)))
  885.          (SETQ VFACT (TRUFAC V FACTZ (NREVERSE VFACT) T MODULU*))
  886.          (SETQ FACTZ NIL)
  887.          (COND ((NULL (CDR VFACT)) (RETURN (LIST U)))
  888.            (T (RETURN (MAPCAR (FUNCTION OLDREP) VFACT))))))
  889.  
  890.  
  891.  
  892. (DEFUN NPROD (LC U LFUNCT) 
  893.        (PROG (STAGE V D2 AF0 R LCINDEX FACTOR LLC LTUPLE LPROD LINDEX QNT AF
  894.           FUNCT TUPLE LTEMP LPR F L LI LF MODULUS HMODULUS) 
  895.          (SETQ LPR (COPY (SETQ LTEMP (CONS NIL NIL))))
  896.          (SETQ LPROD (CONS NIL LFUNCT))
  897.          (SETQ D2 (QUOTIENT (CADR U) 2))
  898.          (REMOV0 LPROD D2)
  899.          (SETQ LFUNCT (CDR LPROD))
  900.          (SETQ LINDEX (INDEX* (SETQ R (LENGTH LFUNCT))))
  901.          (COND ((NOT MONIC*)
  902.             (SETQ LLC (MAPCAR (FUNCTION CADDR) LFUNCT))
  903.             (SETQ LCINDEX (COPY1 LINDEX))
  904.             (REMOV3 LLC LCINDEX)
  905.             (SETQ V (PTIMES LC (PTIMES (CADDR U) U))))
  906.            (T (SETQ V U)))
  907.          (SETQ LTUPLE (CONS NIL (MAPCAR  #'LIST LINDEX)))
  908.          (SETQ STAGE 1)
  909.          (SETQ LINDEX (CONS NIL LINDEX))
  910.          (SETQ LFUNCT (COPY1 LPROD))
  911.     TLOOP(SETQ STAGE (f1+ STAGE))
  912.     CONT (COND ((OR (GREATERP STAGE D2) (GREATERP STAGE (f1- R)))
  913.             (RETURN (CONS U FACTOR))))
  914.     NEXTUPLE
  915.          (COND ((OR (NULL LTUPLE) (NULL (CDR LTUPLE)))
  916.             (RETURN (CONS U FACTOR))))
  917.          (SETQ LI (CDR LINDEX))
  918.          (SETQ LF (CDR LFUNCT))
  919.          (SETQ TUPLE (CADR LTUPLE))
  920.          (SETQ FUNCT (CADR LPROD))
  921.          (RPLACD LTUPLE (CDDR LTUPLE))
  922.          (RPLACD LPROD (CDDR LPROD))
  923.     ILOOP(SETQ L (CAR LI))
  924.          (SETQ F (CAR LF))
  925.          (SETQ LI (CDR LI))
  926.          (SETQ LF (CDR LF))
  927.          (COND ((AND (NOT (zl-MEMBER L TUPLE))
  928.              (NOT (GREATERP (PLUS (CADR F) (CADR FUNCT)) D2))
  929.              (NOT (zl-MEMBER (SETQ L (ORDE L TUPLE)) LTEMP)))
  930.             (SETQMODULUS PLIM)
  931.             (SETQ AF0 (SETQ AF (PTIMES(PMOD F) (PMOD FUNCT))))
  932.             (COND (LLC (SETQ AF (PTIMES (PMOD (LCHK LLC LCINDEX L)) AF))))
  933.             (COND (MANY* (SETQ AF (DROPTERMS AF)))
  934.               ((AND ALGFAC* (NOT (EQUAL INTBS* 1)))(SETQ AF (INTBASEHK AF))))
  935.             (SETQMODULUS NIL)
  936.             (COND ((SETQ QNT (TESTDIVIDE V AF))
  937.                (COND (LLC (SETQ AF (OLDCONTENT AF))
  938.                       (SETQ V (PTIMES (CAR AF) QNT)AF (CADR AF))
  939.                       (SETQ U (COND (ALGFAC*(CAR (CATCH 'RATERR (RQUOTIENT U AF))))
  940.                             (T (PQUOTIENT U AF)))))
  941.                  (T (SETQ U QNT V QNT)))
  942.                (SETQ FACTOR (CONS AF FACTOR))
  943.                (COND ((EQUAL U 1) (RETURN FACTOR)))
  944.                (SETQ D2 (QUOTIENT (CADR U) 2))
  945.                (COND ((LESSP D2 STAGE) (RETURN (CONS U FACTOR))))
  946.                (REMOV1 L LTUPLE LPROD D2)
  947.                (REMOV1 L LTEMP LPR D2)
  948.                (REMOV2 L LINDEX LFUNCT D2)
  949.                (SETQ R (DIFFERENCE R STAGE))
  950.                (GO CONT))
  951.               (T (SETQ LTEMP (NCONC LTEMP (LIST L)))
  952.                  (SETQ LPR (NCONC LPR (LIST AF0)))))))
  953.          (COND (LI (GO ILOOP)) ((CDR LTUPLE) (GO NEXTUPLE)))
  954.          (SETQ LTUPLE LTEMP LPROD LPR LTEMP NIL LPR NIL)
  955.          (GO TLOOP))) 
  956.  
  957. (DEFUN REMOV2 (A B C D2) 
  958.        (PROG NIL 
  959.     TAG1 (COND ((NULL (CDR B)) (RETURN NIL))
  960.            ((OR (zl-MEMBER (CADR B) A) (GREATERP (CADADR C) D2))
  961.             (RPLACD B (CDDR B))
  962.             (RPLACD C (CDDR C))
  963.             (GO TAG1)))
  964.          (SETQ B (CDR B))
  965.          (SETQ C (CDR C))
  966.          (GO TAG1))) 
  967.  
  968. (DEFUN REMOV1 (A LT1 LP1 D2) 
  969.        (PROG NIL 
  970.     TAG1 (COND ((NULL (CDR LT1)) (RETURN NIL))
  971.            ((AND (NOT (GREATERP (CADADR LP1) D2))
  972.              (NULL (INTERSECT A (CADR LT1))))
  973.             (SETQ LT1 (CDR LT1))
  974.             (SETQ LP1 (CDR LP1))
  975.             (GO TAG1)))
  976.          (RPLACD LT1 (CDDR LT1))
  977.          (RPLACD LP1 (CDDR LP1))
  978.          (GO TAG1))) 
  979.  
  980. (DEFUN REMOV0 (LF D2) 
  981.        (PROG (D)(SETQ D LF) 
  982.     TAG  (COND ((NULL (CDR LF)) (RETURN NIL))
  983.            ((GREATERP (CADADR LF) D2)(SETQ D2 (CADDR (CADR LF))) (RPLACD LF (CDDR LF))
  984. (COND ((EQUAL D2 1) NIL)(T (RPLACD D (CONS (PTIMES D2 (CADR D)) (CDDR D)))))
  985. (RETURN NIL)))
  986.          (SETQ LF (CDR LF))
  987.          (GO TAG)))
  988.  
  989. (DEFUN REMOV3 (A B) 
  990.        (PROG NIL 
  991. LOOP         (COND ((NULL (CDR A)) (RETURN NIL))
  992.            ((EQUAL (CADR A) 1)
  993.             (RPLACD A (CDDR A))
  994.             (RPLACD B (CDDR B))(GO LOOP)))
  995.          (SETQ A (CDR A) B (CDR B))(GO LOOP))) 
  996.  
  997. (DEFUN LCHK (A B C) 
  998.        (PROG (ANS) 
  999.          (SETQ ANS 1)
  1000.     LOOP (COND ((NULL A) (RETURN ANS))
  1001.            ((NOT (zl-MEMBER (CAR B) C)) (SETQ ANS (PTIMES ANS (CAR A)))))
  1002.          (SETQ A (CDR A) B (CDR B))
  1003.          (GO LOOP))) 
  1004.  
  1005.  
  1006.  
  1007. (DEFUN LCPRODL (L) 
  1008.        (PROG (ANS D) 
  1009.          (SETQ D 1 L (REVERSE L) ANS '(1))
  1010.     LOOP (COND ((NULL (CDR L)) (RETURN ANS)))
  1011.          (SETQ D (PTIMES D (CADDAR L)))
  1012.          (SETQ L (CDR L))
  1013.          (SETQ ANS (CONS D ANS))
  1014.          (GO LOOP))) 
  1015.  
  1016.  
  1017. (DEFUN FACT5 (POLY) 
  1018.        (PROG (QL TRL* LINFAC UU* LC DEG FACTP FACTZ MODULUS MONIC*  SPLIT* VAR
  1019.           ANOTYPE FCTC INVC AFIXN FCTCFIXN INVCFIXN) 
  1020.          (SETQ VAR (CAR POLY))
  1021.          (COND ((NULL (CDDDR POLY)) (RETURN (LIST POLY))))
  1022.          (COND((AND ALGFAC* (NOT (ATOM (CADDR POLY))))
  1023.            (SETQ ALC (CADDR POLY))
  1024.            (SETQ POLY (RATTIMES (CONS POLY 1) (SETQ ALCINV(RAINV ALC)) T))
  1025.            (SETQ ADN*(TIMES ADN* (CDR POLY)))
  1026.            (SETQ POLY (CAR POLY))))
  1027.          (COND((AND ALGFAC* MINPOLY* (OR $NALGFAC (EQUAL (CDR MINPOLY*) '(4 1 0 1))))
  1028.            (SETQ QL 'SPLITCASE) (GO TAG0)))
  1029.          (SETQ UU* POLY)
  1030.          (COND ((EQUAL (SETQ LC (CADDR UU*)) 1) (SETQ MONIC* T)))
  1031.          (SETQ DEG (CADR POLY))
  1032.          (COND ((NOT ALGFAC*)
  1033.             (SETQ FCTCFIXN (*ARRAY NIL 'fixnum DEG)
  1034.               INVCFIXN (*ARRAY NIL 'fixnum DEG)
  1035.               AFIXN (*ARRAY NIL 'fixnum DEG DEG)))
  1036.            (T (SETQ FCTC (*ARRAY NIL T DEG)
  1037.                 INVC (*ARRAY NIL T DEG)
  1038.                 ANOTYPE (*ARRAY NIL T DEG DEG)
  1039.                 FCTCFIXN (*ARRAY NIL 'fixnum MM*)
  1040.                 INVCFIXN (*ARRAY NIL 'fixnum MM*)
  1041.                 AFIXN (*ARRAY NIL 'fixnum MM* MM*))))
  1042.          (COND (MODULU* (RETURN (FACT5MOD POLY))))
  1043.          (COND ((NOT (ATOM (SETQ QL (CHOOZP UU*))))
  1044.             (SETQ LINFAC (CAR QL) UU* (CADDR QL) QL (CADR QL))))
  1045.          (SETQ *PRIME MODULUS)
  1046. TAG0         (COND ((EQ QL 'SPLITCASE) 
  1047.             (SETQ POLY(NALGFAC POLY (CONS (CAR ALPHA) (CDR MINPOLY*))))
  1048.             (SETQ PLIM *ALPHA *PRIME PLIM LIMK -1)
  1049.             (RETURN POLY))
  1050.            ((NULL (CDR (APPEND LINFAC QL)))
  1051.             (SETQ POLY (LIST POLY))
  1052.             (GO OUT))
  1053.            ((EQUAL UU* 1) (SETQ FACTP NIL) (GO ON)))
  1054.          (COND  (ALGFAC* (SETQ FACTP (CPBGZASS QL  UU* (LENGTH QL))))
  1055.            ((NOT (EQUAL UU* 1))
  1056.             (SETQ FACTP (CPBG QL  UU* (LENGTH QL)))))
  1057.          (SETQ UU* NIL)
  1058.     ON   (SETQ FACTP (NCONC FACTP LINFAC) 
  1059.             LINFAC NIL
  1060.  FACTP (CONS (PCTIMES (PMOD LC) (CAR FACTP)) (CDR FACTP)))
  1061.          (SETQ LIMK (KLIM POLY MODULUS))
  1062.          (SETQ FACTZ (ZFACT POLY FACTP LIMK NIL)FACTP NIL)
  1063.          (SETQ POLY (TRUFAC POLY
  1064.                 ((LAMBDA (MODULUS) (RESTORELC FACTZ LC)) PLIM)
  1065.                 (NREVERSE FACTZ)
  1066.                 NIL
  1067.                 NIL))
  1068.          (SETQ MODULUS NIL)
  1069. ;(COND ((NULL (CDR POLY))(GO OUT)) not needed and doesn't work?
  1070. ;(ALGFAC* (SETQ ADN* (PTIMES ADN*(PQUOTIENT 
  1071. ;(APPLY (FUNCTION TIMES) (MAPCAR (FUNCTION CADDR) POLY)) (TIMES ADN* LC))))))
  1072.     OUT  (RETURN POLY)))
  1073.  
  1074.  
  1075.  
  1076. (DEFUN FACT5MOD (U)
  1077.        (PROG (LC POLY)
  1078.          (SETQ POLY (COPY1 U))
  1079.          (SETQMODULUS MODULU*)
  1080.          (SETQ POLY (PMOD POLY))         
  1081.          (SETQ LC (CADDR POLY))
  1082.          (PMONICIZE (CDR POLY))
  1083.          (SETQ POLY(CPBERL POLY))
  1084.          (COND ((NULL (CDR POLY))
  1085.             (RETURN (LIST U)))
  1086.            (T (RETURN (COND ((EQUAL LC 1) POLY)
  1087.                     (T (CONS LC POLY))))))))
  1088.  
  1089.  
  1090. (DEFUN CPBG (QLIST V M)
  1091.      (declare (fixnum m))
  1092.        (PROG (Y VJ FACTORS U W (J 0)
  1093.           (P1  (// MODULUS 2))
  1094.           (P2 1)
  1095.           FNJ FNQ OLDFAC) 
  1096.          (DECLARE (FIXNUM J P1 P2))
  1097.          (COND ((= M 1) (RETURN (LIST V))))
  1098.          (SETQ P1 (// MODULUS 2))
  1099.          (SETQ P2 1)
  1100.          (SETQ QLIST (CDR (NREVERSE QLIST)))
  1101.          (SETQ OLDFAC (LIST NIL V))
  1102.          (SETQ V NIL)
  1103.     TAG3 (SETQ VJ (NCONC (CAR QLIST) (LIST 0 0)))
  1104.          (SETQ QLIST (CDR QLIST))
  1105.          (SETQ J (f- P1))
  1106.          (SETQ OLDFAC (NCONC OLDFAC FNQ))
  1107.          (SETQ FNQ NIL)
  1108.     INCRJ(SETQ FACTORS (NCONC OLDFAC FNJ))
  1109.          (SETQ FNJ NIL)
  1110.          (PCDIFCONC VJ J)
  1111.     TAG2 (SETQ U (CADR FACTORS))
  1112.          (SETQ W (PGCDU VJ U))
  1113.          (COND ((OR (NUMBERP W) (= (CADR W) (CADR U))) (GO AGG)))
  1114.          (SETQ Y (CAR (PMODQUO U W)))
  1115.          (SETQ FNQ (CONS (COPY1 W) FNQ))
  1116.          (SETQ FNJ (CONS Y FNJ))
  1117.          (SETQ P2 (f1+ P2))
  1118.          (RPLACD FACTORS (CDDR FACTORS))
  1119.          (COND ((EQUAL P2 M) (GO OUT)) (T (GO TAG1)))
  1120.     AGG  (SETQ FACTORS (CDR FACTORS))
  1121.     TAG1 (COND ((CDR FACTORS) (GO TAG2))
  1122.            ((< J P1) (SETQ J (f1+ J)) (GO INCRJ))
  1123.            (QLIST (GO TAG3)))
  1124.     OUT  (RETURN (NCONC FNQ FNJ (CDR OLDFAC)))))
  1125.  
  1126.  
  1127.  
  1128.  
  1129. (DEFUN FACT2Z (U F G LIMK) 
  1130.        (PROG (A A1 W PK MPK B C R P QL QLP H (K 0) B1)
  1131.                 (DECLARE (FIXNUM K))
  1132.          (SETQ P MODULUS)
  1133.          (SETQ R (PPPROG F G))
  1134.          (SETQ A (CAR R))
  1135.          (SETQ B (CADR R))
  1136.          (LET ((MODULUS NIL))
  1137.            (SETQ R (PDIFFERENCE (PTIMES F G) U)))
  1138.       SHARP (COND ((OR (EQUAL R 0) (> K LIMK)) (GO ON)))
  1139.          (SETQ PK MODULUS MPK (MINUS PK))
  1140.          (SETQ MODULUS (TIMES MODULUS MODULUS))
  1141.          (SETQ W (PMOD R))
  1142.          (COND ((EQUAL W 0) (GO TAG1)))
  1143.          (SETQ C (NPQUO W PK))(SETQ W NIL)
  1144.          (SETQ QL (PMODQUO (PTIMES A C) G))
  1145.          (SETQ A1 (NPCTIMES MPK
  1146.                 (PPLUS (PTIMES (CAR QL) F)
  1147.                        (PTIMES B C))))
  1148.          (SETQ B1 (NPCTIMES MPK (CDR QL)))
  1149.          (LET ((MODULUS PLIM)) 
  1150.            (SETQ R (PPLUS (PPLUS R (PTIMES A1 B1))
  1151.                   (PPLUS (PTIMES A1 G) (PTIMES B1 F))))
  1152.            (SETQ F (PPLUS F A1))
  1153.            (SETQ G (PPLUS G B1)))
  1154.          (SETQ A1 NIL B1 NIL)
  1155. TAG1         (COND ((OR (EQUAL R 0)(> (SETQ K(f1+ K)) LIMK)) (GO ON)))
  1156.              (SETQ H (NPQUO (PPLUS (PPLUS (PTIMES A F)
  1157.                       (PTIMES B G))
  1158.                    -1)
  1159.                 PK))
  1160.          (SETQ QLP (PMODQUO (PTIMES A H) G))
  1161.          (SETQ B1 (PPLUS (PTIMES B H) (PTIMES (CAR QLP) F)))
  1162.          (SETQ A (PPLUS A (NPCTIMES MPK (CDR QLP))))
  1163.          (SETQ B (PPLUS B (NPCTIMES MPK B1)))
  1164.          (SETQ H NIL B1 NIL QLP NIL)
  1165.          (GO SHARP)
  1166.         ON   (SETQMODULUS P)
  1167.          (RETURN (LIST F G))))
  1168.  
  1169.  
  1170.  
  1171. (DEFUN NPCTIMES (C P)
  1172.        (SETQ P (NPCTIMES1 C P))
  1173.        (COND ((AND (NOT (ATOM P)) (NULL (CDR P))) 0)
  1174.          (T P)))
  1175.  
  1176. (DEFUN NPQUO (P C)
  1177.        (PROG (U MODULUS)
  1178.          (COND ((EQUAL C 1)(RETURN P))
  1179.            ((PCOEFP P)(RETURN (QUOTIENT P C))))
  1180.          (SETQ U P)
  1181.     LOOP (COND ((NULL (CDR U))(RETURN P)))
  1182.          (SETQ U (CDDR U))
  1183.          (RPLACA U (COND ((PCOEFP (CAR U))
  1184.                   (QUOTIENT (CAR U) C))
  1185.                  (T (NPQUO (COPY1 (CAR U)) C))))
  1186.          (GO LOOP)))
  1187.  
  1188. (DEFUN NPCTIMES1 (C P)
  1189.        (PROG (U A)
  1190.          (COND((EQUAL C 1)(RETURN P))
  1191.           ((PCOEFP P)(RETURN (CTIMES C P))))
  1192.          (SETQ U P)
  1193.     LOOP (COND ((NULL (CDR U))(RETURN P)))
  1194.          (SETQ A (COND ((PCOEFP (CADDR U)) (CTIMES C (CADDR U)))
  1195.                (T (NPCTIMES C (COPY1 (CADDR U))))))
  1196.          (COND ((EQUAL A 0) (RPLACD U (CDDDR U)))
  1197.            (T (SETQ U (CDDR U))
  1198.               (RPLACA U A)))
  1199.          (GO LOOP)))
  1200.  
  1201. (DEFUN X**Q1 (TERM U M P) 
  1202.        (DECLARE (FIXNUM M))
  1203.        (PROG ((I 1) )
  1204.          (declare (fixnum i))
  1205.          (SETQ TRL* (LIST TERM))
  1206.     LOOP (COND ((= I M) (RETURN (PEXPTMOD TERM P U))))
  1207.          (SETQ TERM (PEXPTMOD TERM P U))
  1208.          (SETQ TRL* (CONS TERM TRL*))
  1209.          (SETQ I (f1+ I))
  1210.          (GO LOOP)))
  1211.  
  1212. ;(DECLARE (ARRAY* (NOTYPE A 2 INVC 1 FCTC 1)))
  1213.  
  1214. (DEFUN CPTOMF (P U N) 
  1215.        (DECLARE (FIXNUM N P  ))
  1216.        (PROG (L S *XN (J 0) (I 0) IND (N-1(f1- n)) )
  1217.          (declare (fixnum i j))
  1218.     LOOP (SETQ J (f1+ J))
  1219.          (COND ((= J N) (RETURN NIL))
  1220.            (IND (GO SA))
  1221.            ((> (f* P J) N-1)
  1222.             (SETQ *XN (MAPCAR (FUNCTION -) (P2CPOL (CDDR U) N-1))
  1223.               S (COPY *XN)
  1224.               IND T)
  1225.             (SETQ I (f- (f* P J) N))
  1226.             (GO SA1)))
  1227.          (SETQ S (P2CPOL (LIST VAR (f* P J) 1) N-1))
  1228.          (GO ST)
  1229.     SA   (SETQ I P)
  1230.     SA1  (COND ((= I 0) (GO ST)))
  1231.          (CPTIMESX S)
  1232.          (SETQ I (f1- I))
  1233.          (GO SA1)
  1234.     ST   (COND ((AND (= J 1)
  1235.              (EQUAL '(1 0) (NCDR S (f1- (LENGTH S) )))
  1236.              (= 1 (APPLY (FUNCTION +) S)))
  1237.             (RETURN (SETQ SPLIT* T))))
  1238.          (SETQ L S)
  1239.          (SETQ I N-1)
  1240.     sharp2  (COND ((NULL L) (GO ON)))
  1241.          (STORE (AFIXN J I) (CAR L))
  1242.          (SETQ L (CDR L))
  1243.          (SETQ I (f1- I))
  1244.          (GO sharp2)
  1245.     ON   (STORE (AFIXN J J) (f- (AFIXN J J) 1))
  1246.          (GO LOOP)))
  1247.  
  1248. (DEFUN P2CPOL (P N) 
  1249.        (DECLARE (FIXNUM N))
  1250.        (PROG (L) 
  1251.          (SETQ P (CDR P))
  1252.     LOOP (COND ((= N -1) (RETURN (NREVERSE L)))
  1253.            ((OR (NULL P) (> N (CAR P))) (SETQ L (CONS 0 L)))
  1254.            ((= N (CAR P))
  1255.             (SETQ L (CONS (CADR P) L))
  1256.             (SETQ P (CDDR P))))
  1257.          (SETQ N (f1- N))
  1258.          (GO LOOP)))
  1259.  
  1260. (DEFUN CPTIMESX (P) 
  1261.        (PROG (XN Q LC) 
  1262.          (SETQ XN *XN Q P LC (CAR P))
  1263.     LOOP (COND ((CDR Q)
  1264.             (RPLACA Q (CPLUS (CADR Q) (CTIMES LC (CAR XN))))
  1265.             (SETQ Q (CDR Q) XN (CDR XN)))
  1266.            (T (RPLACA Q (CTIMES LC (CAR XN))) (RETURN P)))
  1267.          (GO LOOP)))
  1268.  
  1269.  
  1270. (DEFUN CMNULLF (N) 
  1271.        (DECLARE (FIXNUM N))
  1272.        (PROG (NULLSP MONE (K 1) (J 0) S  ( N-1 (f1- N))  NULLV VJ M AKS)
  1273.          (declare (fixnum k j n-1))
  1274.          #-cl ;too hard to sort these out now.
  1275.             (DECLARE (FIXNUM AKS M N J S K SUB1N VJ))
  1276.          (SETQ MONE (CMOD -1))
  1277.          (DO ((I 0 (f1+ I))) ((> I N-1))
  1278.          (STORE (FCTCFIXN I) -1)
  1279.          (STORE (INVCFIXN I) -1))
  1280.          (SETQ  NULLSP (LIST 1))
  1281.     N2   (COND ((> K N-1) (RETURN NULLSP)))
  1282.          (SETQ J 0)
  1283.     N3A  (COND ((> J N-1) (GO NULL))
  1284.            ((OR (= (AFIXN K J) 0) (> (FCTCFIXN J) -1))
  1285.             (SETQ J (f1+ J))
  1286.             (GO N3A)))
  1287.          (STORE (INVCFIXN K) J)
  1288.          (STORE (FCTCFIXN J) K)
  1289.          (SETQ M (AFIXN K J))
  1290.          (SETQ M (CRECIP (CTIMES MONE M)))
  1291.          (DO ((S K (f1+ S))) ((> S N-1))
  1292.          (STORE (AFIXN S J) (CTIMES M (AFIXN S J))))
  1293.          (COMMENT (GO THROUGH COLUMNS))
  1294.          (SETQ S 0)
  1295.     sharp2  (COND ((> S N-1) (GO NEXTK)))
  1296.          (COMMENT (GO THROUGH ROWS IN EACH COLUMN))
  1297.          (COND ((= S J) NIL)
  1298.            (T (SETQ AKS (AFIXN K S))
  1299.               (DO ((I K (f1+ I))) ((> I N-1))
  1300.               (STORE (AFIXN I S)
  1301.                  (CPLUS (AFIXN I S)
  1302.                     (CTIMES (AFIXN I J) AKS))))))
  1303.          (SETQ S (f1+ S))
  1304.          (GO sharp2)
  1305.     NULL (SETQ NULLV NIL)
  1306.          (DO ((S 0 (f1+ S))) ((> S N-1))
  1307.          (COND ((= S K) (SETQ NULLV (CONS S (CONS 1 NULLV))))
  1308.                ((> (INVCFIXN S) -1)
  1309.             (SETQ VJ (AFIXN K (INVCFIXN S)))
  1310.             (COND ((= VJ 0) NIL)
  1311.                   (T (SETQ NULLV (CONS S (CONS VJ NULLV))))))))
  1312.          (COND ((EQUAL (CAR NULLV) 0) (SETQ NULLV (CADR NULLV)))
  1313.            ((SETQ NULLV (CONS VAR NULLV))))
  1314.          (SETQ NULLSP (CONS NULLV NULLSP))
  1315.     NEXTK(SETQ K (f1+ K))
  1316.          (GO N2)))
  1317.  
  1318.  
  1319. (DEFUN CHOOZP (V) 
  1320.        #-cl (DECLARE (FIXNUM NCONT N NF MINCONT LMIN ALGCONT))
  1321.        (PROG (LCHAR1 U TR N (NCONT 1) BMOD B1 B MINCONT (LMIN 0) (NF 0)
  1322.           (DEG  (CADR V)) (ALGCONT 0))
  1323.          (declare (special ncont lmin nf deg algcont))
  1324.          (SETQ NF (HAULONG  DEG))
  1325.          (SETQ LCHAR1 (COND (GAUSS '(3 7 11. 19. 23. 29. 31. 37.))
  1326.                 (T SMALLPRIMES)))
  1327.     TEST (SETQ MODULUS (CAR LCHAR1))
  1328.          (SETQ U (PMOD V))
  1329.          (COND ((OR (ZEROP (REMAINDER SHARPCONT MODULUS))
  1330.             (AND (NOT MONIC*)
  1331.                  (OR (PCOEFP U)
  1332.                  (> DEG (CADR U)))))
  1333.             (GO NEXTP)))
  1334.          (COND ((OR (NULL (SQFRP U VAR))
  1335.             (AND ALGFAC*
  1336.                  (NOT GAUSS)
  1337.                    (NOT (IREDUP (PMOD MINPOLY*)))
  1338.                  ))
  1339.              (SETQ ALGCONT(f1+ ALGCONT))
  1340.             (GO NEXTP)))
  1341.          (PMONICIZE (CDR U))
  1342.          (SETQ B1 (CATCH 'SPLT (CPBER1 U)))(SETQ ALGCONT 0)
  1343.          (SETQ NCONT (f1+ NCONT))
  1344.          (SETQ N (f+ (LENGTH (CAR B1)) (LENGTH (CADR B1))))
  1345.          (COND ((OR (ZEROP LMIN) (< N LMIN))
  1346.             (SETQ LMIN N  MINCONT 1 BMOD MODULUS B B1)
  1347.             (COND (ALGFAC* (SETQ TR TRL*))))
  1348.            ((= N LMIN) (SETQ MINCONT (f1+ MINCONT))))
  1349.          (COND ((OR (> NCONT NF) (NOT(> N NF)) (= MINCONT 3)) (GO OUT)))
  1350.     NEXTP(SETQ LCHAR1 (CDR LCHAR1))
  1351.          (COND ((NULL LCHAR1)
  1352.             (COND ((NOT (ZEROP LMIN)) (GO OUT))
  1353.               (T (MERROR "Factor ran out of primes."))))
  1354.            ((> ALGCONT 6)
  1355.             (COND ((ZIREDUP MINPOLY*)(SETQ TRL* TR)(SETQ MODULUS NIL)
  1356.                          (RETURN 'SPLITCASE))
  1357.               (T (MERROR "The minimal poly must be irreducible over the integers.")))))
  1358.          (GO TEST)
  1359.     OUT  (SETQ MODULUS BMOD TRL* TR)
  1360.          (RETURN B)))
  1361.  
  1362.  
  1363. (DEFUN CPBQ1 (A N) 
  1364.        (DECLARE (FIXNUM  N ))
  1365.        (PROG () 
  1366.          (SETQ SPLIT* NIL)
  1367.          (COND ((NOT (INTEGERP MODULUS)) (*ARRAY 'A T N N)))
  1368.          (COND ((OR ALGFAC* (NOT (INTEGERP MODULUS)))
  1369.             (CPTOM MODULUS MM* A N))
  1370.            (T (CPTOMF MODULUS A N)))
  1371.          (COND (SPLIT*
  1372.             (RETURN (POWRS (CAR A) (CADR A)))))
  1373.          (RETURN (COND ((OR ALGFAC* (NOT (INTEGERP MODULUS)))
  1374.                 (CMNULL N))
  1375.                (T (CMNULLF N))))))
  1376.  
  1377.  
  1378. (DEFUN CPBER1 (U) 
  1379.        (PROG (LINFAC) 
  1380.          (SETQ VAR (CAR U))
  1381.          (SETQ LINFAC
  1382.            (LINOUT U)
  1383.            U
  1384.            (CAR LINFAC)
  1385.            LINFAC
  1386.            (CADR LINFAC))
  1387.          (COND ((EQUAL U 1) (RETURN (LIST LINFAC NIL U))))
  1388.          (RETURN (LIST LINFAC (CPBQ1 U (CADR U)) U))))
  1389.   
  1390.  
  1391. (DEFUN FACTOR1972 (P) 
  1392.        (LET ((MODULU* MODULUS) MANY* *STOP* MODULUS HMODULUS MCFLAG NEGFLAG) 
  1393.         (COND ((OR (ATOM P) (NUMBERP P)(AND ALGFAC* (ALG P))) (LIST P))
  1394.           (T (FACTOR72 P)))))
  1395.  
  1396. (DEFUN FACTOR72 (P) 
  1397.   (LET ((SHARPCONT 1) PLIM) 
  1398.        (SETQ P (COND ((ONEVARP P) (MAPCAR (FUNCTION POSIZE) (FACT5 P)))
  1399.              ((AND $NEWFAC (NULL MODULUS) (NOT ALGFAC*))
  1400.               (SETQ MANY* T) (NMULTFACT P))
  1401.              (T (SETQ MANY* T) (MULTFACT P))))
  1402.        (COND (NEGFLAG (CONS (PMINUS (CAR P)) (CDR P))) (T P))))
  1403.  
  1404. (DEFUN POSIZE (P) 
  1405.        (COND ((PMINUSP P) (SETQ NEGFLAG (NOT NEGFLAG)) (PMINUS P)) (T P))) 
  1406.  
  1407.  
  1408. ;;moved to rat3c.lisp
  1409. ;#+LISPM
  1410. ;(eval-when (load)
  1411. ;(DO ((I 0 (f1+ I))                ;GENERATES 20 LARGEST
  1412. ;         (P (LSH -1 -1) (NEWPRIME P)))        ;PRIMES < WORD
  1413. ;        ((= I 20.)))
  1414.  
  1415. ;)
  1416.  
  1417. ;(DEFMVAR *ALPHA (CAR BIGPRIMES))
  1418.  
  1419.